home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / symbols.el.z / symbols.el
Encoding:
Text File  |  1998-05-21  |  5.5 KB  |  173 lines
  1. ;;; symbols.el --- functions for working with symbols and symbol values
  2.  
  3. ;; Copyright (C) 1996 Ben Wing.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  19. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22. ;;; Synched up with: Not in FSF.
  23.  
  24. ;;; Not yet dumped into XEmacs.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; The idea behind magic variables is that you can specify arbitrary
  29. ;; behavior to happen when setting or retrieving a variable's value.  The
  30. ;; purpose of this is to make it possible to cleanly provide support for
  31. ;; obsolete variables (e.g. unread-command-event, which is obsolete for
  32. ;; unread-command-events) and variable compatibility
  33. ;; (e.g. suggest-key-bindings, the FSF equivalent of
  34. ;; teach-extended-commands-p and teach-extended-commands-timeout).
  35. ;; 
  36. ;; There are a large number of functions pertaining to a variable's
  37. ;; value:
  38. ;; 
  39. ;; boundp
  40. ;; globally-boundp
  41. ;; makunbound
  42. ;; symbol-value
  43. ;; set / setq
  44. ;; default-boundp
  45. ;; default-value
  46. ;; set-default / setq-default
  47. ;; make-variable-buffer-local
  48. ;; make-local-variable
  49. ;; kill-local-variable
  50. ;; kill-console-local-variable
  51. ;; symbol-value-in-buffer
  52. ;; symbol-value-in-console
  53. ;; local-variable-p / local-variable-if-set-p
  54. ;; 
  55. ;; Plus some "meta-functions":
  56. ;; 
  57. ;; defvaralias
  58. ;; variable-alias
  59. ;; indirect-variable
  60. ;; 
  61. ;; I wanted an implementation that:
  62. ;; 
  63. ;; -- would work with all the above functions, but (a) didn't require
  64. ;;    a separate handler for every function, and (b) would work OK
  65. ;;    even if more functions are added (e.g. `set-symbol-value-in-buffer'
  66. ;;    or `makunbound-default') or if more arguments are added to a
  67. ;;    function.
  68. ;; -- avoided consing if at all possible.
  69. ;; -- didn't slow down operations on non-magic variables (therefore,
  70. ;;    storing the magic information using `put' is ruled out).
  71. ;; 
  72.  
  73. ;;; Code:
  74.  
  75. ;; perhaps this should check whether the functions are bound, so that
  76. ;; some handlers can be unspecified.  That requires that all functions
  77. ;; are defined before `define-magic-variable-handlers' is called,
  78. ;; though.
  79.  
  80. ;; perhaps there should be something that combines
  81. ;; `define-magic-variable-handlers' with `defvaralias'.
  82.  
  83. (defun define-magic-variable-handlers (variable handler-class harg)
  84.   "Set the magic variable handles for VARIABLE to those in HANDLER-CLASS.
  85. HANDLER-CLASS should be a symbol.  The handlers are constructed by adding
  86. the handler type to HANDLER-CLASS.  HARG is passed as the HARG value for
  87. each of the handlers."
  88.   (mapcar
  89.    #'(lambda (htype)
  90.        (set-magic-variable-handler variable htype
  91.                    (intern (concat (symbol-value handler-class)
  92.                            "-"
  93.                            (symbol-value htype)))
  94.                    harg))
  95.    '(get-value set-value other-predicate other-action)))
  96.  
  97. ;; unread-command-event
  98.  
  99. (defun mvh-first-of-list-get-value (sym fun args harg)
  100.   (car (apply fun harg args)))
  101.  
  102. (defun mvh-first-of-list-set-value (sym value setfun getfun args harg)
  103.   (apply setfun harg (cons value (apply getfun harg args)) args))
  104.  
  105. (defun mvh-first-of-list-other-predicate (sym fun args harg)
  106.   (apply fun harg args))
  107.  
  108. (defun mvh-first-of-list-other-action (sym fun args harg)
  109.   (apply fun harg args))
  110.  
  111. (define-magic-variable-handlers 'unread-command-event
  112.   'mvh-first-of-list
  113.   'unread-command-events)
  114.  
  115. ;; last-command-char, last-input-char, unread-command-char
  116.  
  117. (defun mvh-char-to-event-get-value (sym fun args harg)
  118.   (event-to-character (apply fun harg args)))
  119.  
  120. (defun mvh-char-to-event-set-value (sym value setfun getfun args harg)
  121.   (let ((event (apply getfun harg args)))
  122.        (if (event-live-p event)
  123.        nil
  124.      (setq event (allocate-event))
  125.      (apply setfun harg event args))
  126.        (character-to-event value event)))
  127.  
  128. (defun mvh-char-to-event-other-predicate (sym fun args harg)
  129.   (apply fun harg args))
  130.  
  131. (defun mvh-char-to-event-other-action (sym fun args harg)
  132.   (apply fun harg args))
  133.  
  134. (define-magic-variable-handlers 'last-command-char
  135.   'mvh-char-to-event
  136.   'last-command-event)
  137.  
  138. (define-magic-variable-handlers 'last-input-char
  139.   'mvh-char-to-event
  140.   'last-input-event)
  141.  
  142. (define-magic-variable-handlers 'unread-command-char
  143.   'mvh-char-to-event
  144.   'unread-command-event)
  145.  
  146. ;; suggest-key-bindings
  147.  
  148. (set-magic-variable-handler
  149.  'suggest-key-bindings 'get-value
  150.  #'(lambda (sym fun args harg)
  151.      (and (apply fun 'teach-extended-commands-p args)
  152.       (apply fun 'teach-extended-commands-timeout args))))
  153.  
  154. (set-magic-variable-handler
  155.  'suggest-key-bindings 'set-value
  156.  #'(lambda (sym value setfun getfun args harg)
  157.      (apply setfun 'teach-extended-commands-p (not (null value)) args)
  158.      (if value
  159.      (apply 'teach-extended-commands-timeout
  160.            (if (numberp value) value 2) args))))
  161.  
  162. (set-magic-variable-handler
  163.  'suggest-key-bindings 'other-action
  164.  #'(lambda (sym fun args harg)
  165.      (apply fun 'teach-extended-commands-p args)
  166.      (apply fun 'teach-extended-commands-timeout args)))
  167.  
  168. (set-magic-variable-handler 
  169.  'suggest-key-bindings 'other-predicate
  170.  #'(lambda (sym fun args harg)
  171.      (and (apply fun 'teach-extended-commands-p args)
  172.       (apply fun 'teach-extended-commands-timeout args))))
  173.